perm filename BENCH.ZL[LSC,LSP] blob
sn#719127 filedate 1984-08-15 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00021 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00004 00002 BOYER -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00025 00003 BROWSE -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00031 00004 CTAK
C00032 00005 DDERIV -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00035 00006 DERIV -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00037 00007 DESTRU -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00039 00008 DIV2 -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00041 00009 FFT -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00046 00010 FPRINT -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00048 00011 FREAD -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00049 00012 FRPOLY -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00058 00013 PUZZLE -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00064 00014 Begin STAK
C00065 00015 TAK -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00068 00016 TAKL -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00070 00017 TAKR -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00093 00018 TIMER -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00097 00019 TPRINT -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00099 00020 TRAVERSE -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00105 00021 TRIANG -*- Mode:Lisp Package:User Base:10 Lowercase:T -*-
C00108 ENDMK
C⊗;
;;; BOYER -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; The Maclisp Code
(DECLARE (SPECIAL UNIFY-SUBST TEMP-TEMP))
;(DEFUN PTIME NIL (LIST (RUNTIME) (STATUS GCTIME)))
(DEFUN ADD-LEMMA (TERM)
(COND ((AND (NOT (ATOM TERM))
(EQ (CAR TERM)
(QUOTE EQUAL))
(NOT (ATOM (CADR TERM))))
(PUTPROP (CAR (CADR TERM))
(CONS TERM (GET (CAR (CADR TERM))
(QUOTE LEMMAS)))
(QUOTE LEMMAS)))
(T (ERROR (QUOTE ADD-LEMMA-DID-NOT-LIKE-TERM)
TERM))))
(DEFUN ADD-LEMMA-LST (LST)
(COND ((NULL LST)
T)
(T (ADD-LEMMA (CAR LST))
(ADD-LEMMA-LST (CDR LST)))))
(DEFUN APPLY-SUBST (ALIST TERM)
(COND ((ATOM TERM)
(COND ((SETQ TEMP-TEMP (ASSQ TERM ALIST))
(CDR TEMP-TEMP))
(T TERM)))
(T (CONS (CAR TERM)
(APPLY-SUBST-LST ALIST (CDR TERM))))))
(DEFUN APPLY-SUBST-LST (ALIST LST)
(COND ((NULL LST)
NIL)
(T (CONS (APPLY-SUBST ALIST (CAR LST))
(APPLY-SUBST-LST ALIST (CDR LST))))))
(DEFUN FALSEP (X LST)
(OR (EQUAL X (QUOTE (F)))
(MEMBER X LST)))
(DEFUN ONE-WAY-UNIFY (TERM1 TERM2)
(PROGN (SETQ UNIFY-SUBST NIL)
(ONE-WAY-UNIFY1 TERM1 TERM2)))
(DEFUN ONE-WAY-UNIFY1 (TERM1 TERM2)
(COND ((ATOM TERM2)
(COND ((SETQ TEMP-TEMP (ASSQ TERM2 UNIFY-SUBST))
(EQUAL TERM1 (CDR TEMP-TEMP)))
(T (SETQ UNIFY-SUBST (CONS (CONS TERM2 TERM1)
UNIFY-SUBST))
T)))
((ATOM TERM1)
NIL)
((EQ (CAR TERM1)
(CAR TERM2))
(ONE-WAY-UNIFY1-LST (CDR TERM1)
(CDR TERM2)))
(T NIL)))
(DEFUN ONE-WAY-UNIFY1-LST (LST1 LST2)
(COND ((NULL LST1)
T)
((ONE-WAY-UNIFY1 (CAR LST1)
(CAR LST2))
(ONE-WAY-UNIFY1-LST (CDR LST1)
(CDR LST2)))
(T NIL)))
(DEFUN REWRITE (TERM)
(COND ((ATOM TERM)
TERM)
(T (REWRITE-WITH-LEMMAS (CONS (CAR TERM)
(REWRITE-ARGS (CDR TERM)))
(GET (CAR TERM)
(QUOTE LEMMAS))))))
(DEFUN REWRITE-ARGS (LST)
(COND ((NULL LST)
NIL)
(T (CONS (REWRITE (CAR LST))
(REWRITE-ARGS (CDR LST))))))
(DEFUN REWRITE-WITH-LEMMAS (TERM LST)
(COND ((NULL LST)
TERM)
((ONE-WAY-UNIFY TERM (CADR (CAR LST)))
(REWRITE (APPLY-SUBST UNIFY-SUBST (CADDR (CAR LST)))))
(T (REWRITE-WITH-LEMMAS TERM (CDR LST)))))
(DEFUN
SETUP NIL
(ADD-LEMMA-LST
(QUOTE ((EQUAL (COMPILE FORM)
(REVERSE (CODEGEN (OPTIMIZE FORM)
(NIL))))
(EQUAL (EQP X Y)
(EQUAL (FIX X)
(FIX Y)))
(EQUAL (GREATERP X Y)
(LESSP Y X))
(EQUAL (LESSEQP X Y)
(NOT (LESSP Y X)))
(EQUAL (GREATEREQP X Y)
(NOT (LESSP X Y)))
(EQUAL (BOOLEAN X)
(OR (EQUAL X (T))
(EQUAL X (F))))
(EQUAL (IFF X Y)
(AND (IMPLIES X Y)
(IMPLIES Y X)))
(EQUAL (EVEN1 X)
(IF (ZEROP X)
(T)
(ODD (SUB1 X))))
(EQUAL (COUNTPS- L PRED)
(COUNTPS-LOOP L PRED (ZERO)))
(EQUAL (FACT- I)
(FACT-LOOP I 1))
(EQUAL (REVERSE- X)
(REVERSE-LOOP X (NIL)))
(EQUAL (DIVIDES X Y)
(ZEROP (REMAINDER Y X)))
(EQUAL (ASSUME-TRUE VAR ALIST)
(CONS (CONS VAR (T))
ALIST))
(EQUAL (ASSUME-FALSE VAR ALIST)
(CONS (CONS VAR (F))
ALIST))
(EQUAL (TAUTOLOGY-CHECKER X)
(TAUTOLOGYP (NORMALIZE X)
(NIL)))
(EQUAL (FALSIFY X)
(FALSIFY1 (NORMALIZE X)
(NIL)))
(EQUAL (PRIME X)
(AND (NOT (ZEROP X))
(NOT (EQUAL X (ADD1 (ZERO))))
(PRIME1 X (SUB1 X))))
(EQUAL (AND P Q)
(IF P (IF Q (T)
(F))
(F)))
(EQUAL (OR P Q)
(IF P (T)
(IF Q (T)
(F))
(F)))
(EQUAL (NOT P)
(IF P (F)
(T)))
(EQUAL (IMPLIES P Q)
(IF P (IF Q (T)
(F))
(T)))
(EQUAL (FIX X)
(IF (NUMBERP X)
X
(ZERO)))
(EQUAL (IF (IF A B C)
D E)
(IF A (IF B D E)
(IF C D E)))
(EQUAL (ZEROP X)
(OR (EQUAL X (ZERO))
(NOT (NUMBERP X))))
(EQUAL (PLUS (PLUS X Y)
Z)
(PLUS X (PLUS Y Z)))
(EQUAL (EQUAL (PLUS A B)
(ZERO))
(AND (ZEROP A)
(ZEROP B)))
(EQUAL (DIFFERENCE X X)
(ZERO))
(EQUAL (EQUAL (PLUS A B)
(PLUS A C))
(EQUAL (FIX B)
(FIX C)))
(EQUAL (EQUAL (ZERO)
(DIFFERENCE X Y))
(NOT (LESSP Y X)))
(EQUAL (EQUAL X (DIFFERENCE X Y))
(AND (NUMBERP X)
(OR (EQUAL X (ZERO))
(ZEROP Y))))
(EQUAL (MEANING (PLUS-TREE (APPEND X Y))
A)
(PLUS (MEANING (PLUS-TREE X)
A)
(MEANING (PLUS-TREE Y)
A)))
(EQUAL (MEANING (PLUS-TREE (PLUS-FRINGE X))
A)
(FIX (MEANING X A)))
(EQUAL (APPEND (APPEND X Y)
Z)
(APPEND X (APPEND Y Z)))
(EQUAL (REVERSE (APPEND A B))
(APPEND (REVERSE B)
(REVERSE A)))
(EQUAL (TIMES X (PLUS Y Z))
(PLUS (TIMES X Y)
(TIMES X Z)))
(EQUAL (TIMES (TIMES X Y)
Z)
(TIMES X (TIMES Y Z)))
(EQUAL (EQUAL (TIMES X Y)
(ZERO))
(OR (ZEROP X)
(ZEROP Y)))
(EQUAL (EXEC (APPEND X Y)
PDS ENVRN)
(EXEC Y (EXEC X PDS ENVRN)
ENVRN))
(EQUAL (MC-FLATTEN X Y)
(APPEND (FLATTEN X)
Y))
(EQUAL (MEMBER X (APPEND A B))
(OR (MEMBER X A)
(MEMBER X B)))
(EQUAL (MEMBER X (REVERSE Y))
(MEMBER X Y))
(EQUAL (LENGTH (REVERSE X))
(LENGTH X))
(EQUAL (MEMBER A (INTERSECT B C))
(AND (MEMBER A B)
(MEMBER A C)))
(EQUAL (NTH (ZERO)
I)
(ZERO))
(EQUAL (EXP I (PLUS J K))
(TIMES (EXP I J)
(EXP I K)))
(EQUAL (EXP I (TIMES J K))
(EXP (EXP I J)
K))
(EQUAL (REVERSE-LOOP X Y)
(APPEND (REVERSE X)
Y))
(EQUAL (REVERSE-LOOP X (NIL))
(REVERSE X))
(EQUAL (COUNT-LIST Z (SORT-LP X Y))
(PLUS (COUNT-LIST Z X)
(COUNT-LIST Z Y)))
(EQUAL (EQUAL (APPEND A B)
(APPEND A C))
(EQUAL B C))
(EQUAL (PLUS (REMAINDER X Y)
(TIMES Y (QUOTIENT X Y)))
(FIX X))
(EQUAL (POWER-EVAL (BIG-PLUS1 L I BASE)
BASE)
(PLUS (POWER-EVAL L BASE)
I))
(EQUAL (POWER-EVAL (BIG-PLUS X Y I BASE)
BASE)
(PLUS I (PLUS (POWER-EVAL X BASE)
(POWER-EVAL Y BASE))))
(EQUAL (REMAINDER Y 1)
(ZERO))
(EQUAL (LESSP (REMAINDER X Y)
Y)
(NOT (ZEROP Y)))
(EQUAL (REMAINDER X X)
(ZERO))
(EQUAL (LESSP (QUOTIENT I J)
I)
(AND (NOT (ZEROP I))
(OR (ZEROP J)
(NOT (EQUAL J 1)))))
(EQUAL (LESSP (REMAINDER X Y)
X)
(AND (NOT (ZEROP Y))
(NOT (ZEROP X))
(NOT (LESSP X Y))))
(EQUAL (POWER-EVAL (POWER-REP I BASE)
BASE)
(FIX I))
(EQUAL (POWER-EVAL (BIG-PLUS (POWER-REP I BASE)
(POWER-REP J BASE)
(ZERO)
BASE)
BASE)
(PLUS I J))
(EQUAL (GCD X Y)
(GCD Y X))
(EQUAL (NTH (APPEND A B)
I)
(APPEND (NTH A I)
(NTH B (DIFFERENCE I (LENGTH A)))))
(EQUAL (DIFFERENCE (PLUS X Y)
X)
(FIX Y))
(EQUAL (DIFFERENCE (PLUS Y X)
X)
(FIX Y))
(EQUAL (DIFFERENCE (PLUS X Y)
(PLUS X Z))
(DIFFERENCE Y Z))
(EQUAL (TIMES X (DIFFERENCE C W))
(DIFFERENCE (TIMES C X)
(TIMES W X)))
(EQUAL (REMAINDER (TIMES X Z)
Z)
(ZERO))
(EQUAL (DIFFERENCE (PLUS B (PLUS A C))
A)
(PLUS B C))
(EQUAL (DIFFERENCE (ADD1 (PLUS Y Z))
Z)
(ADD1 Y))
(EQUAL (LESSP (PLUS X Y)
(PLUS X Z))
(LESSP Y Z))
(EQUAL (LESSP (TIMES X Z)
(TIMES Y Z))
(AND (NOT (ZEROP Z))
(LESSP X Y)))
(EQUAL (LESSP Y (PLUS X Y))
(NOT (ZEROP X)))
(EQUAL (GCD (TIMES X Z)
(TIMES Y Z))
(TIMES Z (GCD X Y)))
(EQUAL (VALUE (NORMALIZE X)
A)
(VALUE X A))
(EQUAL (EQUAL (FLATTEN X)
(CONS Y (NIL)))
(AND (NLISTP X)
(EQUAL X Y)))
(EQUAL (LISTP (GOPHER X))
(LISTP X))
(EQUAL (SAMEFRINGE X Y)
(EQUAL (FLATTEN X)
(FLATTEN Y)))
(EQUAL (EQUAL (GREATEST-FACTOR X Y)
(ZERO))
(AND (OR (ZEROP Y)
(EQUAL Y 1))
(EQUAL X (ZERO))))
(EQUAL (EQUAL (GREATEST-FACTOR X Y)
1)
(EQUAL X 1))
(EQUAL (NUMBERP (GREATEST-FACTOR X Y))
(NOT (AND (OR (ZEROP Y)
(EQUAL Y 1))
(NOT (NUMBERP X)))))
(EQUAL (TIMES-LIST (APPEND X Y))
(TIMES (TIMES-LIST X)
(TIMES-LIST Y)))
(EQUAL (PRIME-LIST (APPEND X Y))
(AND (PRIME-LIST X)
(PRIME-LIST Y)))
(EQUAL (EQUAL Z (TIMES W Z))
(AND (NUMBERP Z)
(OR (EQUAL Z (ZERO))
(EQUAL W 1))))
(EQUAL (GREATEREQPR X Y)
(NOT (LESSP X Y)))
(EQUAL (EQUAL X (TIMES X Y))
(OR (EQUAL X (ZERO))
(AND (NUMBERP X)
(EQUAL Y 1))))
(EQUAL (REMAINDER (TIMES Y X)
Y)
(ZERO))
(EQUAL (EQUAL (TIMES A B)
1)
(AND (NOT (EQUAL A (ZERO)))
(NOT (EQUAL B (ZERO)))
(NUMBERP A)
(NUMBERP B)
(EQUAL (SUB1 A)
(ZERO))
(EQUAL (SUB1 B)
(ZERO))))
(EQUAL (LESSP (LENGTH (DELETE X L))
(LENGTH L))
(MEMBER X L))
(EQUAL (SORT2 (DELETE X L))
(DELETE X (SORT2 L)))
(EQUAL (DSORT X)
(SORT2 X))
(EQUAL (LENGTH (CONS X1
(CONS X2
(CONS X3 (CONS X4
(CONS X5
(CONS X6 X7)))))))
(PLUS 6 (LENGTH X7)))
(EQUAL (DIFFERENCE (ADD1 (ADD1 X))
2)
(FIX X))
(EQUAL (QUOTIENT (PLUS X (PLUS X Y))
2)
(PLUS X (QUOTIENT Y 2)))
(EQUAL (SIGMA (ZERO)
I)
(QUOTIENT (TIMES I (ADD1 I))
2))
(EQUAL (PLUS X (ADD1 Y))
(IF (NUMBERP Y)
(ADD1 (PLUS X Y))
(ADD1 X)))
(EQUAL (EQUAL (DIFFERENCE X Y)
(DIFFERENCE Z Y))
(IF (LESSP X Y)
(NOT (LESSP Y Z))
(IF (LESSP Z Y)
(NOT (LESSP Y X))
(EQUAL (FIX X)
(FIX Z)))))
(EQUAL (MEANING (PLUS-TREE (DELETE X Y))
A)
(IF (MEMBER X Y)
(DIFFERENCE (MEANING (PLUS-TREE Y)
A)
(MEANING X A))
(MEANING (PLUS-TREE Y)
A)))
(EQUAL (TIMES X (ADD1 Y))
(IF (NUMBERP Y)
(PLUS X (TIMES X Y))
(FIX X)))
(EQUAL (NTH (NIL)
I)
(IF (ZEROP I)
(NIL)
(ZERO)))
(EQUAL (LAST (APPEND A B))
(IF (LISTP B)
(LAST B)
(IF (LISTP A)
(CONS (CAR (LAST A))
B)
B)))
(EQUAL (EQUAL (LESSP X Y)
Z)
(IF (LESSP X Y)
(EQUAL T Z)
(EQUAL F Z)))
(EQUAL (ASSIGNMENT X (APPEND A B))
(IF (ASSIGNEDP X A)
(ASSIGNMENT X A)
(ASSIGNMENT X B)))
(EQUAL (CAR (GOPHER X))
(IF (LISTP X)
(CAR (FLATTEN X))
(ZERO)))
(EQUAL (FLATTEN (CDR (GOPHER X)))
(IF (LISTP X)
(CDR (FLATTEN X))
(CONS (ZERO)
(NIL))))
(EQUAL (QUOTIENT (TIMES Y X)
Y)
(IF (ZEROP Y)
(ZERO)
(FIX X)))
(EQUAL (GET J (SET I VAL MEM))
(IF (EQP J I)
VAL
(GET J MEM)))))))
(DEFUN TAUTOLOGYP (X TRUE-LST FALSE-LST)
(COND ((TRUEP X TRUE-LST)
T)
((FALSEP X FALSE-LST)
NIL)
((ATOM X)
NIL)
((EQ (CAR X)
(QUOTE IF))
(COND ((TRUEP (CADR X)
TRUE-LST)
(TAUTOLOGYP (CADDR X)
TRUE-LST FALSE-LST))
((FALSEP (CADR X)
FALSE-LST)
(TAUTOLOGYP (CADDDR X)
TRUE-LST FALSE-LST))
(T (AND (TAUTOLOGYP (CADDR X)
(CONS (CADR X)
TRUE-LST)
FALSE-LST)
(TAUTOLOGYP (CADDDR X)
TRUE-LST
(CONS (CADR X)
FALSE-LST))))))
(T NIL)))
(DEFUN TAUTP (X)
(TAUTOLOGYP (REWRITE X)
NIL NIL))
(DEFUN TEST NIL
(PROG (ANS TERM)
(SETQ TERM
(APPLY-SUBST
(QUOTE ((X F (PLUS (PLUS A B)
(PLUS C (ZERO))))
(Y F (TIMES (TIMES A B)
(PLUS C D)))
(Z F (REVERSE (APPEND (APPEND A B)
(NIL))))
(U EQUAL (PLUS A B)
(DIFFERENCE X Y))
(W LESSP (REMAINDER A B)
(MEMBER A (LENGTH B)))))
(QUOTE (IMPLIES (AND (IMPLIES X Y)
(AND (IMPLIES Y Z)
(AND (IMPLIES Z U)
(IMPLIES U W))))
(IMPLIES X W)))))
(SETQ ANS (TAUTP TERM))))
(DEFUN TRANS-OF-IMPLIES (N)
(LIST (QUOTE IMPLIES)
(TRANS-OF-IMPLIES1 N)
(LIST (QUOTE IMPLIES)
0 N)))
(DEFUN TRANS-OF-IMPLIES1 (N)
(COND ((EQUAL N 1)
(LIST (QUOTE IMPLIES)
0 1))
(T (LIST (QUOTE AND)
(LIST (QUOTE IMPLIES)
(SUB1 N)
N)
(TRANS-OF-IMPLIES1 (SUB1 N))))))
(DEFUN TRUEP (X LST)
(OR (EQUAL X (QUOTE (T)))
(MEMBER X LST)))
; (INCLUDE "TIMER.LSP")
; (TIMER TIMIT (TEST))
(deftimer boyer
(test))
(SETUP)
;;; BROWSE -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Benchmark to create and browse through an AI-like data base of units
;;; n is # of symbols
;;; m is maximum amount of stuff on the plist
;;; npats is the number of basic patterns on the unit
;;; ipats is the instantiated copies of the patterns
; (declare (fixsw t))
(defun init (n m npats ipats)
(let ((ipats (subst () () ipats)))
(do ((p ipats (cdr p)))
((null (cdr p)) (rplacd p ipats)))
(do ((n n (1- n))
(i m (cond ((= i 0) m)
(t (1- i))))
(name (intern (gensym)) (intern (gensym)))
(a ()))
((= n 0) a)
(push name a)
(do ((i i (1- i)))
((= i 0))
(putprop name() (gensym)))
(putprop
name
(do ((i npats (1- i))
(ipats ipats (cdr ipats))
(a ()))
((= i 0) a)
(push (car ipats) a))
'pattern)
(do ((j (- m i) (1- j)))
((= j 0))
(putprop name () (gensym))))))
(defmacro mod (x n) `(remainder ,x ,n))
(declare (special rand)) ; (fixnum rand))
(setq rand 21.)
(defun seed () (setq rand 21.))
(defun browse-random () (setq rand (mod (* rand 17.) 251.)))
(defun randomize (l)
(do ((a ()))
((null l) a)
(let ((n (mod (browse-random) (length l))))
(cond ((= n 0)
(push (car l) a)
(setq l (cdr l)))
(t
(do ((n n (1- n))
(x l (cdr x)))
((= n 1)
(push (cadr x) a)
(rplacd x (cddr x)))))))))
; (defmacro char1 (x) `(getchar ,x 1))
(defmacro char1 (x) `(aref (get-pname ,x) 0))
(defun match (pat dat alist)
(cond ((null pat)
(null dat))
((null dat) ())
((or (eq (car pat) '?) ;
(eq (car pat)
(car dat)))
(match (cdr pat) (cdr dat) alist))
((eq (car pat) '*)
(or (match (cdr pat) dat alist)
(match (cdr pat) (cdr dat) alist)
(match pat (cdr dat) alist)))
(t (cond ((atom (car pat))
(cond ((eq (char1 (car pat)) #/?) ; long story
(let ((val (assq (car pat) alist)))
(cond (val (match (cons (cdr val)
(cdr pat))
dat alist))
(t (match (cdr pat)
(cdr dat)
(cons (cons (car pat)
(car dat))
alist))))))
((eq (char1 (car pat)) #/*)
(let ((val (assq (car pat) alist)))
(cond (val (match (append (cdr val)
(cdr pat))
dat alist))
(t
(do ((l () (nconc l (ncons (car d))))
(e (cons () dat) (cdr e))
(d dat (cdr d)))
((null e) ())
(cond ((match (cdr pat) d
(cons (cons (car pat) l)
alist))
(return t))))))))))
(t (and
(not (atom (car dat)))
(match (car pat)
(car dat) alist)
(match (cdr pat)
(cdr dat) alist)))))))
(defun browse ()
(seed)
(investigate (randomize
(init 100. 10. 4. '((a a a b b b b a a a a a b b a a a)
(a a b b b b a a
(a a)(b b))
(a a a b (b a) b a b a))))
'((*a ?b *b ?b a *a a *b *a)
(*a *b *b *a (*a) (*b))
(? ? * (b a) * ? ?))))
(defun investigate (units pats)
(do ((units units (cdr units)))
((null units))
(do ((pats pats (cdr pats)))
((null pats))
(do ((p (get (car units) 'pattern)
(cdr p)))
((null p))
(match (car pats) (car p) ())))))
;(include "timer.lsp")
;(timer timit
; (browse))
(deftimer browse
(browse))
;;; CTAK
;;; TAK using CATCH/THROW. Intended, along with STAK to replace SCCPP.
(Defun ctak (x y z)
(*catch 'ctak (tak1 x y z)))
(defun tak1 (x y z)
(cond ((not (< y x)) ;x≤y
(*throw 'ctak z))
(t (tak1
(*catch 'ctak
(tak1 (1- x)
y
z))
(*catch 'ctak
(tak1 (1- y)
z
x))
(*catch 'ctak
(tak1 (1- z)
x
y))))))
(deftimer ctak (ctak 18. 12. 6.))
;;; DDERIV -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
(DEFUN DER1 (A) (LIST 'QUOTIENT (DDERIV A) A))
(DEFUN (PLUS DDERIV) (A)
(CONS 'PLUS (MAPCAR 'DDERIV A)))
(DEFUN (DIFFERENCE DDERIV) (A)
(CONS 'DIFFERENCE (MAPCAR 'DDERIV
A)))
(DEFUN (TIMES DDERIV) (A)
(LIST 'TIMES (CONS 'TIMES A)
(CONS 'PLUS (MAPCAR 'DER1 A))))
(DEFUN (QUOTIENT DDERIV) (A)
(LIST 'DIFFERENCE
(LIST 'QUOTIENT
(DDERIV (CAR A))
(CADR A))
(LIST 'QUOTIENT
(CAR A)
(LIST 'TIMES
(CADR A)
(CADR A)
(DDERIV (CADR A))))))
(DEFUN DDERIV (A)
(COND
((ATOM A)
(COND ((EQ A 'X) 1) (T 0)))
(T (LET ((DDERIV (GET (CAR A) 'DDERIV)))
(COND (DDERIV (FUNCALL DDERIV (CDR A)))
(T 'ERROR))))))
(DEFUN RUN ()
(DECLARE (FIXNUM I))
(DO ((I 0 (1+ I)))
((= I 1000.))
(DDERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DDERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DDERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DDERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DDERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))))
;(include "timer.lsp")
;(timer timit
; (run))
(deftimer dderiv (run))
;;; DERIV -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
; (DECLARE (MAPEX T))
(DEFUN DER1 (A) (LIST 'QUOTIENT (DERIV A) A))
(DEFUN DERIV (A)
(COND
((ATOM A)
(COND ((EQ A 'X) 1) (T 0)))
((EQ (CAR A) 'PLUS) (CONS 'PLUS (MAPCAR 'DERIV (CDR A))))
((EQ (CAR A) 'DIFFERENCE)
(CONS 'DIFFERENCE (MAPCAR 'DERIV
(CDR A))))
((EQ (CAR A) 'TIMES)
(LIST 'TIMES
A
(CONS 'PLUS (MAPCAR 'DER1 (CDR A)))))
((EQ (CAR A) 'QUOTIENT)
(LIST 'DIFFERENCE
(LIST 'QUOTIENT
(DERIV (CADR A))
(CADDR A))
(LIST 'QUOTIENT
(CADR A)
(LIST 'TIMES
(CADDR A)
(CADDR A)
(DERIV (CADDR A))))))
(T 'ERROR)))
(DEFUN RUN ()
(DECLARE (FIXNUM I))
(DO ((I 0 (1+ I)))
((= I 1000.))
(DERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))
(DERIV '(PLUS (TIMES 3 X X) (TIMES A X X) (TIMES B X) 5))))
; (include "timer.lsp")
;(timer timit
; (run))
(deftimer deriv (run))
;;; DESTRU -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Destructive operation benchmark
; (declare (fixsw t))
(defun destructive (n m)
(let ((l (do ((i 10. (1- i))
(a () (push () a)))
((= i 0) a))))
(do ((i n (1- i)))
((= i 0))
(cond ((null (car l))
(do ((l l (cdr l)))
((null l))
(or (car l)
(rplaca l (ncons ())))
(nconc (car l)
(do ((j m (1- j))
(a () (push () a)))
((= j 0) a)))))
(t
(do ((l1 l (cdr l1))
(l2 (cdr l) (cdr l2)))
((null l2))
(rplacd (do ((j (// (length (car l2)) 2) (1- j))
(a (car l2) (cdr a)))
((= j 0) a)
(rplaca a i))
(let ((n (// (length (car l1)) 2)))
(cond ((= n 0) (rplaca l1 ())
(car l1))
(t
(do ((j n (1- j))
(a (car l1) (cdr a)))
((= j 1)
(prog1 (cdr a)
(rplacd a ())))
(rplaca a i))))))))))))
;(include "timer.lsp")
;(timer timit (destructive 600. 50.))
(deftimer destru (destructive 600. 50.))
;;; DIV2 -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Dividing by 2 using lists of n ()'s
;(declare (fixsw t))
(defun create-n (n)
(do ((n n (1- n))
(a () (push () a)))
((= n 0) a)))
(defun div2 (l)
(do ((l l (cddr l))
(a () (push (car l) a)))
((null l) a)))
(defun dv2 (l)
(cond ((null l) ())
(t (cons (car l) (dv2 (cddr l))))))
(defun test1 (l)
(do ((i 300. (1- i)))
((= i 0))
(div2 l)
(div2 l)
(div2 l)
(div2 l)))
(defun test2 (l)
(do ((i 300. (1- i)))
((= i 0))
(dv2 l)
(dv2 l)
(dv2 l)
(dv2 l)))
(declare (special l))
(setq l (create-n 200.))
;(include "timer.lsp")
;(timer timit1
; (test1 l))
;(timer timit2
; (test2 l))
(defmacro div2-bench ()
'(progn
(print 'div2-test1)
(deftimer div2 (test1 l))
(timit "Iterative test. Compiled code on the 3600.")
(print 'div2-test2)
(deftimer div2 (test2 l))
(timit "Recursive test. Compiled code on the 3600.")))
;;; FFT -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;;Barrow FFT
;;;Here is the Barrow FFT benchmark which tests floating operations
;;;of various types, including flonum arrays. (ARRAYCALL FLONUM A I)
;;;accesses the I'th element of the FLONUM array A, where these arrays are
;;;0-based. (STORE (ARRAYCALL FLONUM A I) V) stores the value V in the
;;;I'th element of the FLONUM array A.
;;;There was a fair amount of FLONUM GC's in the SAIL MacLisp run, which,
;;;when it needed to CORE up during GC, took 4.5 seconds of CPU time for the
;;;computation and 15 seconds for GC. Other configurations of memory required
;;;only 1.5 seconds for GC.
;;;Refer to this as FFT.
;;; -rpg-
;;; *-*lisp*-*
;;; From Rich Duda, by way of Harry Barrow -- 3/26/82
(defvar re (make-array 1025. ':initial-value 0.0))
(defvar im (make-array 1025. ':initial-value 0.0))
(DEFUN FFT ;Fast Fourier Transform
(AREAL AIMAG) ;AREAL = real part
(PROG ;AIMAG = imaginary part
(AR AI PI I J K M N LE LE1 IP NV2 NM1 UR UI WR WI TR TI)
(SETQ AR AREAL ;Initialize
AI AIMAG
PI 3.141592653589793
N (ARRAY-DIMENSION-N 1 AR)
N (1- N)
NV2 (// N 2)
NM1 (1- N)
M 0 ;Compute M = log(N)
I 1)
L1 (COND ((< I N)
(SETQ M (1+ M)
I (+ I I))
(GO L1)))
(COND ((NOT (EQUAL N (↑ 2 M)))
(PRINC "Error ... array size not a power of two.")
(READ)
(RETURN (TERPRI))))
(SETQ J 1 ;Interchange elements
I 1) ;in bit-reversed order
L3 (COND ((< I J)
(SETQ TR (AREF AR J)
TI (AREF AI J))
(ASET (AREF AR I) AR J)
(ASET (AREF AI I) AI J)
(ASET TR AR I)
(ASET TI AI I)))
(SETQ K NV2)
L6 (COND ((< K J)
(SETQ J (- J K)
K (// K 2))
(GO L6)))
(SETQ J (+ J K)
I (1+ I))
(COND ((< I N)
(GO L3)))
(DO L 1 (1+ L) (> L M) ;Loop thru stages
(SETQ LE (↑ 2 L)
LE1 (// LE 2)
UR 1.0
UI 0.
WR (COS (// PI (FLOAT LE1)))
WI (SIN (// PI (FLOAT LE1))))
(DO J 1 (1+ J) (> J LE1) ;Loop thru butterflies
(DO I J (+ I LE) (> I N) ;Do a butterfly
(SETQ IP (+ I LE1)
TR (- (* (AREF AR IP) UR)
(* (AREF AI IP) UI))
TI (+ (* (AREF AR IP) UI)
(* (AREF AI IP) UR)))
(ASET (- (AREF AR I) TR) AR IP)
(ASET (- (AREF AI I) TI) AI IP)
(ASET (+ (AREF AR I) TR) AR I)
(ASET (+ (AREF AI I) TI) AI I)))
(SETQ TR (- (* UR WR) (* UI WI))
TI (+ (* UR WI) (* UI WR))
UR TR
UI TI))
(RETURN T)))
;;; The timer which does 10 calls on FFT
;(include "timer.lsp")
;(timer timit
; (do ((ntimes 0 (1+ ntimes)))
; ((= ntimes 10.))
; (fft 're 'im)))
(deftimer fft
(do ((ntimes 0 (1+ ntimes)))
((= ntimes 10.))
(fft re im)))
;;; FPRINT -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Benchmark to print to a file.
(defconst fprint-test-file "local:>timings>fprint.test")
(defun init (m n atoms)
(let ((atoms (subst () () atoms)))
(do ((a atoms (cdr a)))
((null (cdr a)) (rplacd a atoms)))
(init1 m n atoms)))
(defun init1 (m n atoms)
(cond ((= m 0) (pop atoms))
(t (do ((i n (- i 2))
(a ()))
((< i 1) a)
(push (pop atoms) a)
(push (init1 (1- m) n atoms) a)))))
(declare (special test-atoms))
(setq test-atoms '(abcdef12 cdefgh23 efghij34 ghijkl45 ijklmn56 klmnop67
mnopqr78 opqrst89 qrstuv90 stuvwx01 uvwxyz12
wxyzab23 xyzabc34 123456ab 234567bc 345678cd
456789de 567890ef 678901fg 789012gh 890123hi))
(declare (special test-pattern))
(setq test-pattern (init 6. 6. test-atoms))
(defun fprint ()
(cond ((probef fprint-test-file )
(deletef fprint-test-file)))
(let ((f (open fprint-test-file '(out ascii))))
(print test-pattern f)
(close f)))
(cond ((probef fprint-test-file))
(t
(let ((f (open fprint-test-file '(out ascii))))
(print test-pattern f)
(close f))))
(deftimer fprint (fprint))
;;; FREAD -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Benchmark to read from a file.
(defconst fread-test-file "local:>timings>fprint.test" "Created by FPRINT")
(defun fread ()
(let ((f (open fread-test-file '(in ascii))))
(read f)
(close f)))
(cond ((probef fread-test-file))
(t
(terpri)
(princ "Define FPRINT.TST using the FPRINT benchmark!")
(let ((f (open fread-test-file '(out ascii))))
(print test-pattern f)
(close f))))
(deftimer fread (fread))
;;; FRPOLY -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Franz Lisp benchmark from Fateman
;; test from Berkeley based on polynomial arithmetic.
(declare (special ans coef f inc i k qq ss v *x*
*alpha *a* *b* *chk *l *p q* u* *var *y*
r r2 r3 start res1 res2 res3))
;(declare (localf pcoefadd pcplus pcplus1 pplus ptimes ptimes1
; ptimes2 ptimes3 psimp pctimes pctimes1
; pplus1))
;; Franz uses maclisp hackery here; you can rewrite lots of ways.
(defmacro pointergp (x y) `(> (get ,x 'order)(get ,y 'order)))
(defmacro pcoefp (e) `(atom ,e))
(defmacro pzerop (x) `(signp e ,x)) ;true for 0 or 0.0
(defmacro pzero () 0)
(defmacro cplus (x y) `(plus ,x ,y))
(defmacro ctimes (x y) `(times ,x ,y))
(defun pcoefadd (e c x) (cond ((pzerop c) x)
(t (cons e (cons c x)))))
(defun pcplus (c p) (cond ((pcoefp p) (cplus p c))
(t (psimp (car p) (pcplus1 c (cdr p))))))
(defun pcplus1 (c x)
(cond ((null x)
(cond ((pzerop c) nil) (t (cons 0 (cons c nil)))))
((pzerop (car x)) (pcoefadd 0 (pplus c (cadr x)) nil))
(t (cons (car x) (cons (cadr x) (pcplus1 c (cddr x)))))))
(defun pctimes (c p) (cond ((pcoefp p) (ctimes c p))
(t (psimp (car p) (pctimes1 c (cdr p))))))
(defun pctimes1 (c x)
(cond ((null x) nil)
(t (pcoefadd (car x)
(ptimes c (cadr x))
(pctimes1 c (cddr x))))))
(defun pplus (x y) (cond ((pcoefp x) (pcplus x y))
((pcoefp y) (pcplus y x))
((eq (car x) (car y))
(psimp (car x) (pplus1 (cdr y) (cdr x))))
((pointergp (car x) (car y))
(psimp (car x) (pcplus1 y (cdr x))))
(t (psimp (car y) (pcplus1 x (cdr y))))))
(defun pplus1 (x y)
(cond ((null x) y)
((null y) x)
((= (car x) (car y))
(pcoefadd (car x)
(pplus (cadr x) (cadr y))
(pplus1 (cddr x) (cddr y))))
((> (car x) (car y))
(cons (car x) (cons (cadr x) (pplus1 (cddr x) y))))
(t (cons (car y) (cons (cadr y) (pplus1 x (cddr y)))))))
(defun psimp (var x)
(cond ((null x) 0)
((atom x) x)
((zerop (car x)) (cadr x))
(t (cons var x))))
(defun ptimes (x y) (cond ((or (pzerop x) (pzerop y)) (pzero))
((pcoefp x) (pctimes x y))
((pcoefp y) (pctimes y x))
((eq (car x) (car y))
(psimp (car x) (ptimes1 (cdr x) (cdr y))))
((pointergp (car x) (car y))
(psimp (car x) (pctimes1 y (cdr x))))
(t (psimp (car y) (pctimes1 x (cdr y))))))
(defun ptimes1 (*x* y) (prog (u* v)
(setq v (setq u* (ptimes2 y)))
a (setq *x* (cddr *x*))
(cond ((null *x*) (return u*)))
(ptimes3 y)
(go a)))
(defun ptimes2 (y) (cond ((null y) nil)
(t (pcoefadd (plus (car *x*) (car y))
(ptimes (cadr *x*) (cadr y))
(ptimes2 (cddr y))))))
(defun ptimes3 (y)
(prog (e u c)
a1 (cond ((null y) (return nil)))
(setq e (+ (car *x*) (car y)))
(setq c (ptimes (cadr y) (cadr *x*) ))
(cond ((pzerop c) (setq y (cddr y)) (go a1))
((or (null v) (> e (car v)))
(setq u* (setq v (pplus1 u* (list e c))))
(setq y (cddr y)) (go a1))
((= e (car v))
(setq c (pplus c (cadr v)))
(cond ((pzerop c) (setq u* (setq v (pdiffer1 u* (list (car v) (cadr v))))))
(t (rplaca (cdr v) c)))
(setq y (cddr y))
(go a1)))
a (cond ((and (cddr v) (> (caddr v) e)) (setq v (cddr v)) (go a)))
(setq u (cdr v))
b (cond ((or (null (cdr u)) (< (cadr u) e))
(rplacd u (cons e (cons c (cdr u)))) (go e)))
(cond ((pzerop (setq c (pplus (caddr u) c))) (rplacd u (cdddr u)) (go d))
(t (rplaca (cddr u) c)))
e (setq u (cddr u))
d (setq y (cddr y))
(cond ((null y) (return nil)))
(setq e (+ (car *x*) (car y)))
(Setq c (ptimes (cadr y) (cadr *x*)))
c (cond ((and (cdr u) (> (cadr u) e)) (setq u (cddr u)) (go c)))
(go b)))
(defun pexptsq (p n)
(do ((n (quotient n 2) (quotient n 2))
(s (cond ((oddp n) p) (t 1))))
((zerop n) s)
(setq p (ptimes p p))
(and (oddp n) (setq s (ptimes s p))) ))
(defun setup nil
(putprop 'x 1 'order)
(putprop 'y 2 'order)
(putprop 'z 3 'order)
(setq r (pplus '(x 1 1 0 1) (pplus '(y 1 1) '(z 1 1)))) ; r= x+y+z+1
(setq r2 (ptimes r 100000)) ;r2 = 100000*r
(setq r3 (ptimes r 1.0)); r3 = r with floating point coefficients
)
; time various computations of powers of polynomials, not counting
;printing but including gc time ; provide account of g.c. time.
;(include "timer.lsp")
;(timer timit1
; (pexptsq r n) n)
;(timer timit2
; (pexptsq r2 n) n)
;(timer timit3
; (pexptsq r3 n) n)
(defmacro bench (n &optional more-documentation)
`(prog ()
(print 'frpoly-test1)
(deftimer frpoly
(pexptsq r ,n) ,n)
(timit (format nil
"Power of polynomial = }D. r = x+y+z+1. }A" ,n ,more-documentation))
(print 'frpoly-test2)
(deftimer frpoly
(pexptsq r2 ,n) ,n)
(timit (format nil
"Power of polynomial = }D. r2 = 100000*r. }A" ,n ,more-documentation))
(print 'frpoly-test3)
(deftimer frpoly
(pexptsq r3 ,n) ,n)
(timit (format nil
"Power of polynomial = }D. r in floating point. }A"
,n ,more-documentation))))
(setup)
; then (bench 2) ; this should be pretty fast.
; then (bench 5)
; then (bench 10)
; then (bench 15)
;...
;;; PUZZLE -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
(eval-when (compile load eval)
(defconst size 511.)
(defconst classmax 3.)
(defconst typemax 12.)
(defconst true t)
(defconst false ()))
(defvar iii 0)
(defvar kount 0)
(defvar d 8.)
(defvar piececount (make-array (1+ classmax) ':initial-value 0))
(defvar class (make-array (1+ typemax) ':initial-value 0))
(defvar piecemax (make-array (1+ typemax) ':initial-value 0))
(defvar puzzle (make-array (1+ size)))
(defvar p (make-array (list (1+ typemax) (1+ size))))
(defun fit (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end) #.true)
(cond ((aref p i k)
(cond ((aref puzzle (+ j k))
(return #.false))))))))
(defun place (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(cond ((aref p i k)
(aset #.true puzzle (+ j k)))))
(aset (- (aref piececount (aref class i)) 1) piececount (aref class i))
(do ((k j (1+ k)))
((> k size)
; (terpri)
; (princ "Puzzle filled")
0)
(cond ((not (aref puzzle k))
(return k))))))
(defun puzzle-remove (i j)
(let ((end (aref piecemax i)))
(do ((k 0 (1+ k)))
((> k end))
(cond ((aref p i k) (aset #.false puzzle (+ j k)))))
(aset (+ (aref piececount (aref class i)) 1) piececount (aref class i))))
(defun trial (j)
(let ((k 0))
(do ((i 0 (1+ i)))
((> i typemax) (setq kount (1+ kount)) #.false)
(cond ((not (= (aref piececount (aref class i)) 0))
(cond ((fit i j)
(setq k (place i j))
(cond ((or (trial k)
(= k 0))
; (format t "}%Piece }4D at }4D." (+ i 1) (+ k 1))
(setq kount (+ kount 1))
(return #.true))
(t (puzzle-remove i j))))))))))
(defun definepiece (iclass ii jj kk)
(let ((index 0))
(do ((i 0 (1+ i)))
((> i ii))
(do ((j 0 (1+ j)))
((> j jj))
(do ((k 0 (1+ k)))
((> k kk))
(setq index (+ i (* d (+ j (* d k)))))
(aset #.true p iii index))))
(aset iclass class iii)
(aset index piecemax iii)
(cond ((not (= iii typemax))
(setq iii (+ iii 1))))))
(defun start ()
(do ((m 0 (1+ m)))
((> m size))
(aset #.true puzzle m))
(do ((i 1 (1+ i)))
((> i 5))
(do ((j 1 (1+ j)))
((> j 5))
(do ((k 1 (1+ k)))
((> k 5))
(aset #.false puzzle (+ i (* d (+ j (* d k))))))))
(do ((i 0 (1+ i)))
((> i typemax))
(do ((m 0 (1+ m)))
((> m size))
(aset #.false p i m)))
(setq iii 0)
(definePiece 0 3 1 0)
(definePiece 0 1 0 3)
(definePiece 0 0 3 1)
(definePiece 0 1 3 0)
(definePiece 0 3 0 1)
(definePiece 0 0 1 3)
(definePiece 1 2 0 0)
(definePiece 1 0 2 0)
(definePiece 1 0 0 2)
(definePiece 2 1 1 0)
(definePiece 2 1 0 1)
(definePiece 2 0 1 1)
(definePiece 3 1 1 1)
(aset 13. pieceCount 0)
(aset 3 pieceCount 1)
(aset 1 pieceCount 2)
(aset 1 pieceCount 3)
(let ((m (+ 1 (* d (+ 1 d))))
(n 0)(kount 0))
(cond ((fit 0 m) (setq n (place 0 m)))
(t (format t "}%Error.")))
(cond ((trial n)
(format t "}%Success in }4D trials." kount))
(t (format t "}%Failure.")))))
(deftimer puzzle (start))
;;; Begin STAK
;;; TAK using special binding in place of parameter passing. Intended, along with CTAK,
;;; to replace SCCPP.
(defvar x)
(defvar y)
(defvar z)
(defun stak-call (x y z)
(stak))
(defun stak ()
(cond ((not (< y x)) ;x≤y
z)
(t (let ((x (let ((x (1- x))
(y y)
(z z))
(stak)))
(y (let ((x (1- y))
(y z)
(z x))
(stak)))
(z (let ((x (1- z))
(y x)
(z y))
(stak))))
(stak)))))
(deftimer stak (stak-call 18. 12. 6.))
;;; TAK -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
(defun tak (x y z)
(cond ((not (< y x)) ;x≤y
z)
(t (tak (tak (1- x) y z)
(tak (1- y) z x)
(tak (1- z) x y)))))
(defun trtak (x y z)
(prog ()
tak
(cond ((not (< y x))
(return z))
(t (let ((a (tak (1- x) y z))
(b (tak (1- y) z x)))
(setq z (tak (1- z) x y))
(setq x a y b)(go tak))))))
(defun btak (x y z)
(prog ()
(cond ((not (< y x))
(return z)))
tak2
(let ((a (let ((c (1- x)))
(cond ((not (< y c)) z)
(t (btak2 c y z)))))
(b (let ((c (1- y)))
(cond ((not (< z c)) x)
(t (btak2 c z x)))))
(c (let ((c (1- z)))
(cond ((not (< x c)) y)
(t (btak2 c x y))))))
(cond ((not (< b a)) (return c))
(t (setq x a
y b
z c)
(go tak2))))))
(defun btak2 (x y z)
(prog ()
tak2
(let ((a (let ((c (1- x)))
(cond ((not (< y c)) z)
(t (btak2 c y z)))))
(b (let ((c (1- y)))
(cond ((not (< z c)) x)
(t (btak2 c z x)))))
(c (let ((c (1- z)))
(cond ((not (< x c)) y)
(t (btak2 c x y))))))
(cond ((not (< b a)) (return c))
(t (setq x a
y b
z c)
(go tak2))))))
(defmacro tak-bench ()
`(prog ()
(print 'tak)
(deftimer tak (tak 18. 12. 6.))
(timit "TAK bench. Compiled version.")
(print 'trtak)
(deftimer tak (trtak 18. 12. 6.))
(timit "Calls TRTAK (alternately structured TAK). Compiled Version.")
(print 'btak)
(deftimer tak (btak 18. 12. 6.))
(timit "Calls BTAK (alternately structure TAK). Compiled Version.")
(print 'nc-tak)
(deftimer tak (tak 10018. 10012. 10006.))
(timit "Calls TAK with much bigger arguments. Compiled Version.")))
;;; TAKL -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
(defun listn (n)
(cond
((= 0 n)
nil)
(t (cons n (listn (1- n))))))
(defun mas (x y z)
(cond
((not (shorterp y x))
z)
(t (mas (mas (cdr x)
y z)
(mas (cdr y)
z x)
(mas (cdr z)
x y)))))
(defun shorterp (x y)
(and y (or (null x)
(shorterp (cdr x)
(cdr y)))))
;benchmark is called
;(mas (listn 18) (listn 12) (listn 6))
;(include "timer.lsp")
;(timer timit
; (mas 18l 12l 6l))
(declare (special 18l 12l 6l))
(setq 18l (listn 18.)
12l (listn 12.)
6l (listn 6.))
(deftimer takl "Calls (mas 18l 12l 6l)" (mas 18l 12l 6l))
;;; TAKR -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Gross Version to try to trash cache.
(deftimer takr (tak0 18. 12. 6.))
(DEFUN TAK0 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK1 (TAK37 (1- X) Y Z)
(TAK11 (1- Y) Z X)
(TAK17 (1- Z) X Y)))))
(DEFUN TAK1 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK2 (TAK74 (1- X) Y Z)
(TAK22 (1- Y) Z X)
(TAK34 (1- Z) X Y)))))
(DEFUN TAK2 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK3 (TAK11 (1- X) Y Z)
(TAK33 (1- Y) Z X)
(TAK51 (1- Z) X Y)))))
(DEFUN TAK3 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK4 (TAK48 (1- X) Y Z)
(TAK44 (1- Y) Z X)
(TAK68 (1- Z) X Y)))))
(DEFUN TAK4 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK5 (TAK85 (1- X) Y Z)
(TAK55 (1- Y) Z X)
(TAK85 (1- Z) X Y)))))
(DEFUN TAK5 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK6 (TAK22 (1- X) Y Z)
(TAK66 (1- Y) Z X)
(TAK2 (1- Z) X Y)))))
(DEFUN TAK6 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK7 (TAK59 (1- X) Y Z)
(TAK77 (1- Y) Z X)
(TAK19 (1- Z) X Y)))))
(DEFUN TAK7 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK8 (TAK96 (1- X) Y Z)
(TAK88 (1- Y) Z X)
(TAK36 (1- Z) X Y)))))
(DEFUN TAK8 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK9 (TAK33 (1- X) Y Z)
(TAK99 (1- Y) Z X)
(TAK53 (1- Z) X Y)))))
(DEFUN TAK9 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK10 (TAK70 (1- X) Y Z)
(TAK10 (1- Y) Z X)
(TAK70 (1- Z) X Y)))))
(DEFUN TAK10 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK11 (TAK7 (1- X) Y Z)
(TAK21 (1- Y) Z X)
(TAK87 (1- Z) X Y)))))
(DEFUN TAK11 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK12 (TAK44 (1- X) Y Z)
(TAK32 (1- Y) Z X)
(TAK4 (1- Z) X Y)))))
(DEFUN TAK12 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK13 (TAK81 (1- X) Y Z)
(TAK43 (1- Y) Z X)
(TAK21 (1- Z) X Y)))))
(DEFUN TAK13 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK14 (TAK18 (1- X) Y Z)
(TAK54 (1- Y) Z X)
(TAK38 (1- Z) X Y)))))
(DEFUN TAK14 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK15 (TAK55 (1- X) Y Z)
(TAK65 (1- Y) Z X)
(TAK55 (1- Z) X Y)))))
(DEFUN TAK15 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK16 (TAK92 (1- X) Y Z)
(TAK76 (1- Y) Z X)
(TAK72 (1- Z) X Y)))))
(DEFUN TAK16 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK17 (TAK29 (1- X) Y Z)
(TAK87 (1- Y) Z X)
(TAK89 (1- Z) X Y)))))
(DEFUN TAK17 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK18 (TAK66 (1- X) Y Z)
(TAK98 (1- Y) Z X)
(TAK6 (1- Z) X Y)))))
(DEFUN TAK18 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK19 (TAK3 (1- X) Y Z)
(TAK9 (1- Y) Z X)
(TAK23 (1- Z) X Y)))))
(DEFUN TAK19 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK20 (TAK40 (1- X) Y Z)
(TAK20 (1- Y) Z X)
(TAK40 (1- Z) X Y)))))
(DEFUN TAK20 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK21 (TAK77 (1- X) Y Z)
(TAK31 (1- Y) Z X)
(TAK57 (1- Z) X Y)))))
(DEFUN TAK21 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK22 (TAK14 (1- X) Y Z)
(TAK42 (1- Y) Z X)
(TAK74 (1- Z) X Y)))))
(DEFUN TAK22 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK23 (TAK51 (1- X) Y Z)
(TAK53 (1- Y) Z X)
(TAK91 (1- Z) X Y)))))
(DEFUN TAK23 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK24 (TAK88 (1- X) Y Z)
(TAK64 (1- Y) Z X)
(TAK8 (1- Z) X Y)))))
(DEFUN TAK24 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK25 (TAK25 (1- X) Y Z)
(TAK75 (1- Y) Z X)
(TAK25 (1- Z) X Y)))))
(DEFUN TAK25 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK26 (TAK62 (1- X) Y Z)
(TAK86 (1- Y) Z X)
(TAK42 (1- Z) X Y)))))
(DEFUN TAK26 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK27 (TAK99 (1- X) Y Z)
(TAK97 (1- Y) Z X)
(TAK59 (1- Z) X Y)))))
(DEFUN TAK27 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK28 (TAK36 (1- X) Y Z)
(TAK8 (1- Y) Z X)
(TAK76 (1- Z) X Y)))))
(DEFUN TAK28 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK29 (TAK73 (1- X) Y Z)
(TAK19 (1- Y) Z X)
(TAK93 (1- Z) X Y)))))
(DEFUN TAK29 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK30 (TAK10 (1- X) Y Z)
(TAK30 (1- Y) Z X)
(TAK10 (1- Z) X Y)))))
(DEFUN TAK30 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK31 (TAK47 (1- X) Y Z)
(TAK41 (1- Y) Z X)
(TAK27 (1- Z) X Y)))))
(DEFUN TAK31 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK32 (TAK84 (1- X) Y Z)
(TAK52 (1- Y) Z X)
(TAK44 (1- Z) X Y)))))
(DEFUN TAK32 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK33 (TAK21 (1- X) Y Z)
(TAK63 (1- Y) Z X)
(TAK61 (1- Z) X Y)))))
(DEFUN TAK33 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK34 (TAK58 (1- X) Y Z)
(TAK74 (1- Y) Z X)
(TAK78 (1- Z) X Y)))))
(DEFUN TAK34 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK35 (TAK95 (1- X) Y Z)
(TAK85 (1- Y) Z X)
(TAK95 (1- Z) X Y)))))
(DEFUN TAK35 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK36 (TAK32 (1- X) Y Z)
(TAK96 (1- Y) Z X)
(TAK12 (1- Z) X Y)))))
(DEFUN TAK36 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK37 (TAK69 (1- X) Y Z)
(TAK7 (1- Y) Z X)
(TAK29 (1- Z) X Y)))))
(DEFUN TAK37 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK38 (TAK6 (1- X) Y Z)
(TAK18 (1- Y) Z X)
(TAK46 (1- Z) X Y)))))
(DEFUN TAK38 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK39 (TAK43 (1- X) Y Z)
(TAK29 (1- Y) Z X)
(TAK63 (1- Z) X Y)))))
(DEFUN TAK39 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK40 (TAK80 (1- X) Y Z)
(TAK40 (1- Y) Z X)
(TAK80 (1- Z) X Y)))))
(DEFUN TAK40 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK41 (TAK17 (1- X) Y Z)
(TAK51 (1- Y) Z X)
(TAK97 (1- Z) X Y)))))
(DEFUN TAK41 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK42 (TAK54 (1- X) Y Z)
(TAK62 (1- Y) Z X)
(TAK14 (1- Z) X Y)))))
(DEFUN TAK42 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK43 (TAK91 (1- X) Y Z)
(TAK73 (1- Y) Z X)
(TAK31 (1- Z) X Y)))))
(DEFUN TAK43 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK44 (TAK28 (1- X) Y Z)
(TAK84 (1- Y) Z X)
(TAK48 (1- Z) X Y)))))
(DEFUN TAK44 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK45 (TAK65 (1- X) Y Z)
(TAK95 (1- Y) Z X)
(TAK65 (1- Z) X Y)))))
(DEFUN TAK45 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK46 (TAK2 (1- X) Y Z)
(TAK6 (1- Y) Z X)
(TAK82 (1- Z) X Y)))))
(DEFUN TAK46 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK47 (TAK39 (1- X) Y Z)
(TAK17 (1- Y) Z X)
(TAK99 (1- Z) X Y)))))
(DEFUN TAK47 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK48 (TAK76 (1- X) Y Z)
(TAK28 (1- Y) Z X)
(TAK16 (1- Z) X Y)))))
(DEFUN TAK48 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK49 (TAK13 (1- X) Y Z)
(TAK39 (1- Y) Z X)
(TAK33 (1- Z) X Y)))))
(DEFUN TAK49 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK50 (TAK50 (1- X) Y Z)
(TAK50 (1- Y) Z X)
(TAK50 (1- Z) X Y)))))
(DEFUN TAK50 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK51 (TAK87 (1- X) Y Z)
(TAK61 (1- Y) Z X)
(TAK67 (1- Z) X Y)))))
(DEFUN TAK51 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK52 (TAK24 (1- X) Y Z)
(TAK72 (1- Y) Z X)
(TAK84 (1- Z) X Y)))))
(DEFUN TAK52 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK53 (TAK61 (1- X) Y Z)
(TAK83 (1- Y) Z X)
(TAK1 (1- Z) X Y)))))
(DEFUN TAK53 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK54 (TAK98 (1- X) Y Z)
(TAK94 (1- Y) Z X)
(TAK18 (1- Z) X Y)))))
(DEFUN TAK54 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK55 (TAK35 (1- X) Y Z)
(TAK5 (1- Y) Z X)
(TAK35 (1- Z) X Y)))))
(DEFUN TAK55 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK56 (TAK72 (1- X) Y Z)
(TAK16 (1- Y) Z X)
(TAK52 (1- Z) X Y)))))
(DEFUN TAK56 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK57 (TAK9 (1- X) Y Z)
(TAK27 (1- Y) Z X)
(TAK69 (1- Z) X Y)))))
(DEFUN TAK57 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK58 (TAK46 (1- X) Y Z)
(TAK38 (1- Y) Z X)
(TAK86 (1- Z) X Y)))))
(DEFUN TAK58 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK59 (TAK83 (1- X) Y Z)
(TAK49 (1- Y) Z X)
(TAK3 (1- Z) X Y)))))
(DEFUN TAK59 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK60 (TAK20 (1- X) Y Z)
(TAK60 (1- Y) Z X)
(TAK20 (1- Z) X Y)))))
(DEFUN TAK60 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK61 (TAK57 (1- X) Y Z)
(TAK71 (1- Y) Z X)
(TAK37 (1- Z) X Y)))))
(DEFUN TAK61 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK62 (TAK94 (1- X) Y Z)
(TAK82 (1- Y) Z X)
(TAK54 (1- Z) X Y)))))
(DEFUN TAK62 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK63 (TAK31 (1- X) Y Z)
(TAK93 (1- Y) Z X)
(TAK71 (1- Z) X Y)))))
(DEFUN TAK63 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK64 (TAK68 (1- X) Y Z)
(TAK4 (1- Y) Z X)
(TAK88 (1- Z) X Y)))))
(DEFUN TAK64 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK65 (TAK5 (1- X) Y Z)
(TAK15 (1- Y) Z X)
(TAK5 (1- Z) X Y)))))
(DEFUN TAK65 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK66 (TAK42 (1- X) Y Z)
(TAK26 (1- Y) Z X)
(TAK22 (1- Z) X Y)))))
(DEFUN TAK66 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK67 (TAK79 (1- X) Y Z)
(TAK37 (1- Y) Z X)
(TAK39 (1- Z) X Y)))))
(DEFUN TAK67 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK68 (TAK16 (1- X) Y Z)
(TAK48 (1- Y) Z X)
(TAK56 (1- Z) X Y)))))
(DEFUN TAK68 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK69 (TAK53 (1- X) Y Z)
(TAK59 (1- Y) Z X)
(TAK73 (1- Z) X Y)))))
(DEFUN TAK69 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK70 (TAK90 (1- X) Y Z)
(TAK70 (1- Y) Z X)
(TAK90 (1- Z) X Y)))))
(DEFUN TAK70 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK71 (TAK27 (1- X) Y Z)
(TAK81 (1- Y) Z X)
(TAK7 (1- Z) X Y)))))
(DEFUN TAK71 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK72 (TAK64 (1- X) Y Z)
(TAK92 (1- Y) Z X)
(TAK24 (1- Z) X Y)))))
(DEFUN TAK72 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK73 (TAK1 (1- X) Y Z)
(TAK3 (1- Y) Z X)
(TAK41 (1- Z) X Y)))))
(DEFUN TAK73 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK74 (TAK38 (1- X) Y Z)
(TAK14 (1- Y) Z X)
(TAK58 (1- Z) X Y)))))
(DEFUN TAK74 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK75 (TAK75 (1- X) Y Z)
(TAK25 (1- Y) Z X)
(TAK75 (1- Z) X Y)))))
(DEFUN TAK75 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK76 (TAK12 (1- X) Y Z)
(TAK36 (1- Y) Z X)
(TAK92 (1- Z) X Y)))))
(DEFUN TAK76 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK77 (TAK49 (1- X) Y Z)
(TAK47 (1- Y) Z X)
(TAK9 (1- Z) X Y)))))
(DEFUN TAK77 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK78 (TAK86 (1- X) Y Z)
(TAK58 (1- Y) Z X)
(TAK26 (1- Z) X Y)))))
(DEFUN TAK78 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK79 (TAK23 (1- X) Y Z)
(TAK69 (1- Y) Z X)
(TAK43 (1- Z) X Y)))))
(DEFUN TAK79 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK80 (TAK60 (1- X) Y Z)
(TAK80 (1- Y) Z X)
(TAK60 (1- Z) X Y)))))
(DEFUN TAK80 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK81 (TAK97 (1- X) Y Z)
(TAK91 (1- Y) Z X)
(TAK77 (1- Z) X Y)))))
(DEFUN TAK81 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK82 (TAK34 (1- X) Y Z)
(TAK2 (1- Y) Z X)
(TAK94 (1- Z) X Y)))))
(DEFUN TAK82 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK83 (TAK71 (1- X) Y Z)
(TAK13 (1- Y) Z X)
(TAK11 (1- Z) X Y)))))
(DEFUN TAK83 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK84 (TAK8 (1- X) Y Z)
(TAK24 (1- Y) Z X)
(TAK28 (1- Z) X Y)))))
(DEFUN TAK84 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK85 (TAK45 (1- X) Y Z)
(TAK35 (1- Y) Z X)
(TAK45 (1- Z) X Y)))))
(DEFUN TAK85 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK86 (TAK82 (1- X) Y Z)
(TAK46 (1- Y) Z X)
(TAK62 (1- Z) X Y)))))
(DEFUN TAK86 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK87 (TAK19 (1- X) Y Z)
(TAK57 (1- Y) Z X)
(TAK79 (1- Z) X Y)))))
(DEFUN TAK87 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK88 (TAK56 (1- X) Y Z)
(TAK68 (1- Y) Z X)
(TAK96 (1- Z) X Y)))))
(DEFUN TAK88 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK89 (TAK93 (1- X) Y Z)
(TAK79 (1- Y) Z X)
(TAK13 (1- Z) X Y)))))
(DEFUN TAK89 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK90 (TAK30 (1- X) Y Z)
(TAK90 (1- Y) Z X)
(TAK30 (1- Z) X Y)))))
(DEFUN TAK90 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK91 (TAK67 (1- X) Y Z)
(TAK1 (1- Y) Z X)
(TAK47 (1- Z) X Y)))))
(DEFUN TAK91 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK92 (TAK4 (1- X) Y Z)
(TAK12 (1- Y) Z X)
(TAK64 (1- Z) X Y)))))
(DEFUN TAK92 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK93 (TAK41 (1- X) Y Z)
(TAK23 (1- Y) Z X)
(TAK81 (1- Z) X Y)))))
(DEFUN TAK93 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK94 (TAK78 (1- X) Y Z)
(TAK34 (1- Y) Z X)
(TAK98 (1- Z) X Y)))))
(DEFUN TAK94 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK95 (TAK15 (1- X) Y Z)
(TAK45 (1- Y) Z X)
(TAK15 (1- Z) X Y)))))
(DEFUN TAK95 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK96 (TAK52 (1- X) Y Z)
(TAK56 (1- Y) Z X)
(TAK32 (1- Z) X Y)))))
(DEFUN TAK96 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK97 (TAK89 (1- X) Y Z)
(TAK67 (1- Y) Z X)
(TAK49 (1- Z) X Y)))))
(DEFUN TAK97 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK98 (TAK26 (1- X) Y Z)
(TAK78 (1- Y) Z X)
(TAK66 (1- Z) X Y)))))
(DEFUN TAK98 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK99 (TAK63 (1- X) Y Z)
(TAK89 (1- Y) Z X)
(TAK83 (1- Z) X Y)))))
(DEFUN TAK99 (X Y Z)
(COND ((NOT (< Y X)) Z)
(T (TAK0 (TAK0 (1- X) Y Z)
(TAK0 (1- Y) Z X)
(TAK0 (1- Z) X Y)))))
;;; TIMER -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Benchmark timing functions for ZetaLisp (successor to "TIMER.LSP").
(defun timed-duration (fn)
(without-interrupts
(// (- (time:microsecond-time)
(progn
(funcall fn)
(time:microsecond-time)))
-1.0e6)))
(defconst *minimum-tests* 3)
(defconst *minimum-duration* 60.0)
(defun multiple-timed-duration (fn)
(let* ((first-time (timed-duration fn))
(repeats (max *minimum-tests*
(1+ (fix (// *minimum-duration* first-time))))))
(loop for repetition from 1 to repeats
summing (timed-duration fn) into total-time
finally (return (// total-time repeats) repeats))))
(defvar *last-deftimer* nil)
(defun ensure-append-file (file)
(unless (probef file)
(with-open-file (ignore file ':out))))
(defun benchmark-time (name documentation fn &aux path)
(setq path (fs:merge-pathnames (string-upcase name) "local:>timings>default.text"))
(ensure-append-file path)
(with-open-file (stream path ':direction ':append)
(format stream "}2%---------- }A ----------}2%}A" name documentation)
(multiple-value-bind (average repeats) (multiple-timed-duration fn)
(format stream "}2%Elapsed Time = }D (average of }D calls)" average repeats))
(format stream "}2%Timing performed by }A on " user-id)
(time:print-current-date stream)
(format stream ".}2%")
(si:print-herald stream)
(format stream "}&--------------------")))
(defmacro deftimer (name &body body)
`(progn 'compile
(defun (:property ,name :timing-function) (.documentation.)
(benchmark-time ',name .documentation. #'(lambda () . ,body)))
(setq *last-deftimer* ',name)))
(defun timit (&optional documentation (deftimer-symbol *last-deftimer*))
(when deftimer-symbol
(funcall (get deftimer-symbol ':timing-function)
(or documentation deftimer-symbol))))
;;; TPRINT -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Benchmark to print and read to the terminal
;(declare (fixsw t))
(defun tprint-init (m n atoms)
(let ((atoms (subst () () atoms)))
(do ((a atoms (cdr a)))
((null (cdr a)) (rplacd a atoms)))
(init1 m n atoms)))
(defun tprint-init1 (m n atoms)
(cond ((= m 0) (pop atoms))
(t (do ((i n (- i 2))
(a ()))
((< i 1) a)
(push (pop atoms) a)
(push (init1 (1- m) n atoms) a)))))
(declare (special test-atoms))
(setq test-atoms '(abc1 cde2 efg3 ghi4 ijk5 klm6 mno7 opq8 qrs9
stu0 uvw1 wxy2 xyz3 123a 234b 345c 456d
567d 678e 789f 890g))
(declare (special test-pattern))
(setq test-pattern (init 6. 6. test-atoms))
;(include "timer.lsp")
;(timer timit (print test-pattern))
(deftimer tprint (print test-pattern))
;;; TRAVERSE -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
;;; Benchmark to create once and traverse a Structure
(defstruct node
(parents ())
(sons ())
(sn (snb))
(entry1 ())
(entry2 ())
(entry3 ())
(entry4 ())
(entry5 ())
(entry6 ())
(mark ()))
(declare (special sn))
(defun snb () (setq sn (1+ sn)))
(setq sn 0)
(defmacro mod (x n) `(remainder ,x ,n))
(defvar rand 21.)
(defun seed () (setq rand 21.))
(defun traverse-random () (setq rand (mod (* rand 17.) 251.)))
(defun traverse-remove (n q)
(cond ((eq (cdr (car q)) (car q))
(prog2 () (caar q) (rplaca q ())))
((= n 0)
(prog2 () (caar q)
(do ((p (car q) (cdr p)))
((eq (cdr p) (car q))
(rplaca q
(rplacd p (cdr (car q))))))))
(t (do ((n n (1- n))
(q (car q) (cdr q))
(p (cdr (car q)) (cdr p)))
((= n 0) (prog2 () (car q) (rplacd q p)))))))
(defun traverse-select (n q)
(do ((n n (1- n))
(q (car q) (cdr q)))
((= n 0) (car q))))
(defun add (a q)
(cond ((null q)
`(,(let ((x `(,a)))
(rplacd x x) x)))
((null (car q))
(let ((x `(,a)))
(rplacd x x)
(rplaca q x)))
(t (rplaca q
(rplacd (car q) `(,a .,(cdr (car q))))))))
(defun create-structure (n)
(let ((a `(,(make-node))))
(do ((m (1- n) (1- m))
(p a))
((= m 0) (setq a `(,(rplacd p a)))
(do ((unused a)
(used (add (traverse-remove 0 a) ()))
(x) (y))
((null (car unused))
(find-root (traverse-select 0 used) n))
(setq x (traverse-remove (mod (traverse-random) n) unused))
(setq y (traverse-select (mod (traverse-random) n) used))
(add x used)
(setf (sons y) `(,x .,(sons y)))
(setf (parents x) `(,y .,(parents x))) ))
(push (make-node) a))))
(defun find-root (node n)
(do ((n n (1- n)))
((= n 0) node)
(cond ((null (parents node))
(return node))
(t (setq node (car (parents node)))))))
(declare (special count marker))
(setq count 0 marker ())
(defun travers (node mark)
(cond ((eq (mark node) mark) ())
(t (setf (mark node) mark)
(setq count (1+ count))
(setf (entry1 node) (not (entry1 node)))
(setf (entry2 node) (not (entry1 node)))
(setf (entry3 node) (not (entry1 node)))
(setf (entry4 node) (not (entry1 node)))
(setf (entry5 node) (not (entry1 node)))
(setf (entry6 node) (not (entry1 node)))
(do ((sons (sons node) (cdr sons)))
((null sons) ())
(travers (car sons) mark)))))
(defun traverse (root)
(let ((count 0))
(travers root (setq marker (not marker)))
count))
;(include "timer.lsp")
(declare (special root))
;(timer init-timit
; (prog2 (setq root (create-structure 100.)) ()))
;(timer timit
; (do ((i 50. (1- i)))
; ((= i 0))
; (traverse root)
; (traverse root)
; (traverse root)
; (traverse root)
; (traverse root)))
(defmacro traverse-bench ()
'(prog ()
(print 'init-traverse)
(deftimer traverse (prog2 (setq root (create-structure 100.)) ()))
(timit "Create data structure for TRAVERSE bench on the LM-2.")
(print 'traverse)
(deftimer traverse
(do ((i 50. (1- i)))
((= i 0))
(traverse root)
(traverse root)
(traverse root)
(traverse root)
(traverse root)))
(timit "LM-2")))
;;; TRIANG -*- Mode:Lisp; Package:User; Base:10; Lowercase:T; -*-
(defvar board (make-array 16. ))
(defvar sequence (make-array 14. ':initial-value 0.))
(defvar a (make-array 37.))
(defvar b (make-array 37.))
(defvar c (make-array 37.))
(defvar answer)
(defvar final)
(fillarray board '(1))
(aset 0 board 5)
(fillarray a '(1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4
4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6))
(fillarray b '(2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5
2 4 7 5 8. 9. 3 6 10. 5 9. 8. 12. 13. 14. 8. 9. 5))
(fillarray c '(4 7 11. 8. 12. 13. 6 10. 15. 9. 14. 13. 13. 14. 15. 9. 10. 6
1 2 4 3 5 6 1 3 6 2 5 4 11. 12. 13. 7 8. 4))
(defun last-position ()
(do ((i 1 (1+ i)))
((= i 16.) 0)
(cond ((= 1 (aref board i)) (return i)))))
(defun try (i depth)
(cond ((= depth 14)
(let ((lp (last-position)))
(cond ((member lp final))
(t (push lp final))))
(push (cdr (listarray sequence)) answer) t)
((and (= 1 (aref board (aref a i)))
(= 1 (aref board (aref b i)))
(= 0 (aref board (aref c i))))
(aset 0 board (aref a i))
(aset 0 board (aref b i))
(aset 1 board (aref c i))
(aset i sequence depth)
(do ((j 0 (1+ j))
(depth (1+ depth)))
((or (= j 36.)
(try j depth)) ()))
(aset 1 board (aref a i))
(aset 1 board (aref b i))
(aset 0 board (aref c i)) ())))
(defun gogogo (i)
(let ((answer ())
(final ()))
(try i 1)))
(deftimer triang
(gogogo 22.))
;(defun triang-test ()
; (let ((answer ())
; (final ()))
; (try 22. 1)
; (= (length answer) 775.)))
ββ